;;; A component is a template that defines a number of views and a
;;; number of layouts that describe how the views are put together. It
;;; is a "meta-widget" and can store values in its defined slots.

(in-package :gwee)

(defclass component (view)
  ())

(defmethod synchronize-width-minimum ((view component) (parent view) width height)
  ;; components always only contain one subview, so just make it the same size as that.
  (synchronize-width (first (view-subviews view)) view width height))

(defmethod synchronize-height-minimum ((view component) (parent view) width height)
  ;; components always only contain one subview, so just make it the same size as that.
  (synchronize-height (first (view-subviews view)) view width height))

(defmacro define-component (name (&rest inherit-classes) (&rest slots) &rest stuff)
  (labels ((sanitize (plist &rest extras)
	     (loop for i = plist then (cddr i)
		while i
		for key = (first i)
		for value = (second i)
		unless (find key (list* :parent :accessor extras))
		nconc (list key value)))
	   (make-slot (x &optional (fn 'cddr))
	     (let ((accessor (getf (funcall fn x) :accessor)))
	       (if accessor
		   (list (first x) :accessor accessor)
		   (list (first x))))))
    (let* ((views (cdr (find :views stuff :key 'first)))
	   (layouts (cdr (find :layouts stuff :key 'first)))
	   (initargs (find :default-initargs stuff :key 'first))
	   (obj (gensym "OBJ"))
	   (slot-names (gensym "SLOT-NAMES"))
	   (top-layout (car layouts))
	   ;; sort the layout views such that they're created in the right order
	   (layout-order (loop with left = layouts
			    while left
			    ;; pick a view whose subviews don't exist in left
			    for v = (find-if (lambda (x) (null (intersection (third x) (mapcar 'first left)))) left)
			    do (assert v () "You have a loop in your layout subviews.")
			    (setf left (remove v left :test 'equal))
			    collect v)))
      (assert (null (set-difference (mapcar 'first stuff) '(:views :layouts :default-initargs)))
	      ()
	      "must be one of :views :layouts :default-initargs")
      (assert (loop for l on layouts
                 always (loop for i in (mapcar 'third (cdr l))
                           never (intersection i (third (car l)))))
              ()
              "A view exists as a subview of more than one layout.")
      (pushnew 'component inherit-classes)
      `(progn
	 (defclass ,name ,inherit-classes
	   (,@slots
	    ,@(mapcar #'make-slot views)
	    ,@(mapcar (lambda (x) (make-slot x 'cdddr)) layouts))
	   ,@(when initargs (list initargs)))
	 (defmethod shared-initialize :after ((,obj ,name) ,slot-names &key)
           (declare (ignore ,slot-names))
	   (with-slots (,@(mapcar 'first slots) ,@(mapcar 'first views) ,@(mapcar 'first layouts)) ,obj
	     (declare (ignorable ,@(mapcar 'first slots)))
	     ,@(loop for i in views
		  collect `(setf ,(first i) (make-instance ',(second i) ,@(sanitize (cddr i)))))
	     ,@(loop for i in layout-order
		  collect `(setf ,(first i)
				 ,(if (equal i top-layout)
				      `(make-instance ',(second i) ,@(sanitize (cdddr i) :subviews)
						      :subviews (list ,@(third i))
;; 						      :x 0 :y 0
;; 						      :width (view-width ,obj)
;; 						      :height (view-height ,obj)
						      :parent ,obj)
				      `(make-instance ',(second i) ,@(sanitize (cdddr i) :subviews) :subviews (list ,@(third i))))))
	     (post-initialize-component ,obj)))))))

(defgeneric post-initialize-component (component)
  (:method-combination progn :most-specific-last)
  (:documentation ""))

(defmethod post-initialize-component progn ((obj component))
  ;; do nuthin.
  )

(defun component-for-view (view &optional (type 'component))
  "Return the component of type TYPE that contains view."
  (find-ancestor-if (lambda (v) (typep v type)) view))

(defmacro with-layout ((views-keyword &rest views) (layouts-keyword &rest layouts) (&key (parent *top-view*) (delete-p t)) &body body)
  (labels ((sanitize (plist &rest slots)
             (setf plist (copy-list plist))
             (dolist (i slots)
               (remf plist i))
             plist))
    (assert (eq views-keyword :views)
            ()
            "views must start with :views keyword")
    (assert (eq layouts-keyword :layouts)
            ()
            "layouts must start with :layouts keyword")
    (assert (loop for l on layouts
                  always (loop for i in (mapcar 'third (cdr l))
                               never (intersection i (third (car l)))))
            ()
            "A view exists as a subview of more than one layout.")
    `(let* (,@(loop for i in views
                 collect `(,(first i)
                            (make-instance ',(second i) ,@(sanitize (cddr i) :parent))))
            ,@(loop for i in layouts for j from 0
                 collect `(,(first i)
                            (make-instance ',(second i) ,@(sanitize (cdddr i) :subviews)
                                           ,@(when (zerop j) `(:parent ,parent))))))
       ;; set the subviews after everything is created to avoid scope
       ;; problems.
       (setf ,@(loop for i in layouts
                  append `((view-subviews ,(first i)) (list ,@(third i)))))
       (unwind-protect
            (progn ,@body)
         (when ,delete-p
           (delete-view ,(caar layouts)))))))
